# mkzip.tcl -- Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
#
#        Create ZIP archives in Tcl.
#
# Create a zipkit using mkzip filename.zkit -zipkit -directory xyz.vfs
# or a zipfile using mkzip filename.zip -directory dirname -exclude "*~"
#
# version 1.2
 
package require Tcl 8.6
 
namespace eval zip {}

# zip::timet_to_dos
#
#        Convert a unix timestamp into a DOS timestamp for ZIP times.
#
#   DOS timestamps are 32 bits split into bit regions as follows:
#                  24                16                 8                 0
#   +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+
#   |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s|
#   +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+
#
proc zip::timet_to_dos {time_t} {
    set s [clock format $time_t -format {%Y %m %e %k %M %S}]
    scan $s {%d %d %d %d %d %d} year month day hour min sec
    expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) 
	  | ($hour << 11) | ($min << 5) | ($sec >> 1)}
}

# zip::pop --
#
#        Pop an element from a list
#
proc zip::pop {varname {nth 0}} {
    upvar $varname args
    set r [lindex $args $nth]
    set args [lreplace $args $nth $nth]
    return $r
}

# zip::walk --
#
#        Walk a directory tree rooted at 'path'. The excludes list can be
#        a set of glob expressions to match against files and to avoid.
#        The match arg is internal.
#        eg: walk library {CVS/* *~ .#*} to exclude CVS and emacs cruft.
#
proc zip::walk {base {excludes ""} {match *} {path {}}} {
    set result {}
    set imatch [file join $path $match]
    set files [glob -nocomplain -tails -types f -directory $base $imatch]
    foreach file $files {
	set excluded 0
	foreach glob $excludes {
	    if {[string match $glob $file]} {
		set excluded 1
		break
	    }
	}
	if {!$excluded} {lappend result $file}
    }
    foreach dir [glob -nocomplain -tails -types d -directory $base $imatch] {
	set subdir [walk $base $excludes $match $dir]
	if {[llength $subdir]>0} {
	    set result [concat $result [list $dir] $subdir]
	}
    }
    return $result
}

# zip::mkzipfile --
#
#        Add a single file to a zip archive. The zipchan channel should
#        already be open and binary. You may provide a comment for the
#        file The return value is the central directory record that
#        will need to be used when finalizing the zip archive.
#
# FIX ME: should  handle the current offset for non-seekable channels
#
proc zip::mkzipfile {zipchan base path {comment ""}} {
    set fullpath [file join $base $path]
    set mtime [timet_to_dos [file mtime $fullpath]]
    if {[file isdirectory $fullpath]} {
	append path /
    }
    set utfpath [encoding convertto utf-8 $path]
    set utfcomment [encoding convertto utf-8 $comment]
    set flags [expr {(1<<11)}] ;# utf-8 comment and path
    set method 0               ;# store 0, deflate 8
    set attr 0                 ;# text or binary (default binary)
    set version 20             ;# minumum version req'd to extract
    set extra ""
    set crc 0
    set size 0
    set csize 0
    set data ""
    set seekable [expr {[tell $zipchan] != -1}]
    if {[file isdirectory $fullpath]} {
	set attrex 0x41ff0010  ;# 0o040777 (drwxrwxrwx)
    } elseif {[file executable $fullpath]} {
	set attrex 0x81ff0080  ;# 0o100777 (-rwxrwxrwx)
    } else {
	set attrex 0x81b60020  ;# 0o100666 (-rw-rw-rw-)
	if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} {
	    set attr 1         ;# text
	}
    }
    
    if {[file isfile $fullpath]} {
	set size [file size $fullpath]
	if {!$seekable} {set flags [expr {$flags | (1 << 3)}]}
    }
    
    set offset [tell $zipchan]
    set local [binary format a4sssiiiiss PK\03\04 \
		   $version $flags $method $mtime $crc $csize $size \
		   [string length $utfpath] [string length $extra]]
    append local $utfpath $extra
    puts -nonewline $zipchan $local
    
    if {[file isfile $fullpath]} {
	# If the file is under 2MB then zip in one chunk, otherwize we use
	# streaming to avoid requiring excess memory. This helps to prevent
	# storing re-compressed data that may be larger than the source when
	# handling PNG or JPEG or nested ZIP files.
	if {$size < 0x00200000} {
	    set fin [open $fullpath rb]
	    set data [read $fin]
	    set crc [zlib crc32 $data]
	    set cdata [zlib deflate $data]
	    if {[string length $cdata] < $size} {
		set method 8
		set data $cdata
	    }
	    close $fin
	    set csize [string length $data]
	    puts -nonewline $zipchan $data
	} else {
	    set method 8
	    set fin [open $fullpath rb]
	    set zlib [zlib stream deflate]
	    while {![eof $fin]} {
		set data [read $fin 4096]
		set crc [zlib crc32 $data $crc]
		$zlib put $data
		if {[string length [set zdata [$zlib get]]]} {
		    incr csize [string length $zdata]
		    puts -nonewline $zipchan $zdata
		}
	    }
	    close $fin
	    $zlib finalize
	    set zdata [$zlib get]
	    incr csize [string length $zdata]
	    puts -nonewline $zipchan $zdata
	    $zlib close
	}
	
	if {$seekable} {
	    # update the header if the output is seekable
	    set local [binary format a4sssiiii PK\03\04 \
			   $version $flags $method $mtime $crc $csize $size]
	    set current [tell $zipchan]
	    seek $zipchan $offset
	    puts -nonewline $zipchan $local
	    seek $zipchan $current
	} else {
	    # Write a data descriptor record
	    set ddesc [binary format a4iii PK\7\8 $crc $csize $size]
	    puts -nonewline $zipchan $ddesc
	}
    }
    
    set hdr [binary format a4ssssiiiisssssii PK\01\02 0x0317 \
		 $version $flags $method $mtime $crc $csize $size \
		 [string length $utfpath] [string length $extra]\
		 [string length $utfcomment] 0 $attr $attrex $offset]
    append hdr $utfpath $extra $utfcomment
    return $hdr
}

# zip::mkzip --
#
#        Create a zip archive in 'filename'. If a file already exists it will be
#        overwritten by a new file. If '-directory' is used, the new zip archive
#        will be rooted in the provided directory.
#        -runtime can be used to specify a prefix file. For instance, 
#        zip myzip -runtime unzipsfx.exe -directory subdir
#        will create a self-extracting zip archive from the subdir/ folder.
#        The -comment parameter specifies an optional comment for the archive.
#
#        eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt
# 
proc zip::mkzip {filename args} {
    array set opts {
	-zipkit 0 -runtime "" -comment "" -directory ""
	-exclude {CVS/* */CVS/* *~ ".#*" "*/.#*"}
    }
    
    while {[string match -* [set option [lindex $args 0]]]} {
	switch -exact -- $option {
	    -zipkit  { set opts(-zipkit) 1 }
	    -comment { set opts(-comment) [encoding convertto utf-8 [pop args 1]] }
	    -runtime { set opts(-runtime) [pop args 1] }
	    -directory {set opts(-directory) [file normalize [pop args 1]] }
	    -exclude {set opts(-exclude) [pop args 1] }
	    -- { pop args ; break }
	    default {
		break
	    }
	}
	pop args
    }
    
    set zf [open $filename wb]
    if {$opts(-runtime) ne ""} {
	set rt [open $opts(-runtime) rb]
	fcopy $rt $zf
	close $rt
    } elseif {$opts(-zipkit)} {
	set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n"
	append zkd "package require vfs::zip\n"
	append zkd "vfs::zip::Mount \[info script\] \[info script\]\n"
	append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n"
	append zkd "    source \[file join \[info script\] main.tcl\]\n"
	append zkd "}\n"
	append zkd \x1A
	puts -nonewline $zf $zkd
    }

    set count 0
    set cd ""

    if {$opts(-directory) ne ""} {
	set paths [zip::walk $opts(-directory) $opts(-exclude)]
    } else {
	set paths [glob -nocomplain {*}$args]
    }
    foreach path $paths {
	append cd [mkzipfile $zf $opts(-directory) $path]
	incr count
    }
    set cdoffset [tell $zf]
    set endrec [binary format a4ssssiis PK\05\06 0 0 \
		    $count $count [string length $cd] $cdoffset\
		    [string length $opts(-comment)]]
    append endrec $opts(-comment)
    puts -nonewline $zf $cd
    puts -nonewline $zf $endrec
    close $zf

    return
}


if {!$tcl_interactive} {
    set r [catch [linsert $argv 0 zip::mkzip] err]
    if {$r} {puts stderr $errorInfo} elseif {[string length $err]} {puts $err}
    exit $r
}

